home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclBasic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-08  |  37.9 KB  |  1,459 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_BASIC
  3. #endif
  4.  
  5. /* 
  6.  * tclBasic.c --
  7.  *
  8.  *    Contains the basic facilities for TCL command interpretation,
  9.  *    including interpreter creation and deletion, command creation
  10.  *    and deletion, and command parsing and execution.
  11.  *
  12.  * Copyright (c) 1987-1993 The Regents of the University of California.
  13.  * All rights reserved.
  14.  *
  15.  * Permission is hereby granted, without written agreement and without
  16.  * license or royalty fees, to use, copy, modify, and distribute this
  17.  * software and its documentation for any purpose, provided that the
  18.  * above copyright notice and the following two paragraphs appear in
  19.  * all copies of this software.
  20.  * 
  21.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  22.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  23.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  24.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  25.  *
  26.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  27.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  28.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  29.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  30.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  31.  */
  32.  
  33. #ifndef lint
  34. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclBasic.c,v 1.153 93/09/09 16:43:19 ouster Exp $ SPRITE (Berkeley)";
  35. #endif
  36.  
  37. #include "tclInt.h"
  38. #ifndef TCL_GENERIC_ONLY
  39. #   include "tclUnix.h"
  40. #endif
  41.  
  42. /*
  43.  * The following structure defines all of the commands in the Tcl core,
  44.  * and the C procedures that execute them.
  45.  */
  46.  
  47. typedef struct {
  48.     char *name;            /* Name of command. */
  49.     Tcl_CmdProc *proc;        /* Procedure that executes command. */
  50. } CmdInfo;
  51.  
  52. /*
  53.  * Built-in commands, and the procedures associated with them:
  54.  */
  55.  
  56. static CmdInfo builtInCmds[] = {
  57.     /*
  58.      * Commands in the generic core:
  59.      */
  60.  
  61.     {"append",        Tcl_AppendCmd},
  62.     {"array",        Tcl_ArrayCmd},
  63.     {"break",        Tcl_BreakCmd},
  64.     {"case",        Tcl_CaseCmd},
  65.     {"catch",        Tcl_CatchCmd},
  66.     {"concat",        Tcl_ConcatCmd},
  67.     {"continue",    Tcl_ContinueCmd},
  68.     {"error",        Tcl_ErrorCmd},
  69.     {"eval",        Tcl_EvalCmd},
  70.     {"expr",        Tcl_ExprCmd},
  71.     {"for",        Tcl_ForCmd},
  72.     {"foreach",        Tcl_ForeachCmd},
  73.     {"format",        Tcl_FormatCmd},
  74.     {"global",        Tcl_GlobalCmd},
  75.     {"history",        Tcl_HistoryCmd},
  76.     {"if",        Tcl_IfCmd},
  77.     {"incr",        Tcl_IncrCmd},
  78.     {"info",        Tcl_InfoCmd},
  79.     {"join",        Tcl_JoinCmd},
  80.     {"lappend",        Tcl_LappendCmd},
  81.     {"lindex",        Tcl_LindexCmd},
  82.     {"linsert",        Tcl_LinsertCmd},
  83.     {"list",        Tcl_ListCmd},
  84.     {"llength",        Tcl_LlengthCmd},
  85.     {"lrange",        Tcl_LrangeCmd},
  86.     {"lreplace",    Tcl_LreplaceCmd},
  87.     {"lsearch",        Tcl_LsearchCmd},
  88.     {"lsort",        Tcl_LsortCmd},
  89.     {"proc",        Tcl_ProcCmd},
  90.     {"regexp",        Tcl_RegexpCmd},
  91.     {"regsub",        Tcl_RegsubCmd},
  92.     {"rename",        Tcl_RenameCmd},
  93.     {"return",        Tcl_ReturnCmd},
  94.     {"scan",        Tcl_ScanCmd},
  95.     {"set",        Tcl_SetCmd},
  96.     {"split",        Tcl_SplitCmd},
  97.     {"string",        Tcl_StringCmd},
  98.     {"switch",        Tcl_SwitchCmd},
  99.     {"trace",        Tcl_TraceCmd},
  100.     {"unset",        Tcl_UnsetCmd},
  101.     {"uplevel",        Tcl_UplevelCmd},
  102.     {"upvar",        Tcl_UpvarCmd},
  103.     {"while",        Tcl_WhileCmd},
  104.  
  105.     /*
  106.      * Commands in the UNIX core:
  107.      */
  108.  
  109. #ifndef TCL_GENERIC_ONLY
  110. #ifndef macintosh
  111.     {"cd",            Tcl_CdCmd},
  112.     {"exec",        Tcl_ExecCmd},
  113.     {"pwd",            Tcl_PwdCmd},
  114. #endif
  115.     {"close",        Tcl_CloseCmd},
  116.     {"eof",        Tcl_EofCmd},
  117.     {"exit",        Tcl_ExitCmd},
  118.     {"file",        Tcl_FileCmd},
  119.     {"flush",        Tcl_FlushCmd},
  120.     {"gets",        Tcl_GetsCmd},
  121.     {"glob",        Tcl_GlobCmd},
  122.     {"open",        Tcl_OpenCmd},
  123.     {"pid",        Tcl_PidCmd},
  124.     {"puts",        Tcl_PutsCmd},
  125.     {"read",        Tcl_ReadCmd},
  126.     {"seek",        Tcl_SeekCmd},
  127.     {"source",        Tcl_SourceCmd},
  128.     {"tell",        Tcl_TellCmd},
  129.     {"time",        Tcl_TimeCmd},
  130. #endif /* TCL_GENERIC_ONLY */
  131.     {NULL,        (Tcl_CmdProc *) NULL}
  132. };
  133.  
  134. /*
  135.  *----------------------------------------------------------------------
  136.  *
  137.  * Tcl_CreateInterp --
  138.  *
  139.  *    Create a new TCL command interpreter.
  140.  *
  141.  * Results:
  142.  *    The return value is a token for the interpreter, which may be
  143.  *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
  144.  *    Tcl_DeleteInterp.
  145.  *
  146.  * Side effects:
  147.  *    The command interpreter is initialized with an empty variable
  148.  *    table and the built-in commands.  SIGPIPE signals are set to
  149.  *    be ignored (see comment below for details).
  150.  *
  151.  *----------------------------------------------------------------------
  152.  */
  153.  
  154. Tcl_Interp *
  155. Tcl_CreateInterp()
  156. {
  157.     register Interp *iPtr;
  158.     register Command *cmdPtr;
  159.     register CmdInfo *cmdInfoPtr;
  160.     int i;
  161.     static int firstInterp = 1;
  162.  
  163.     iPtr = (Interp *) ckalloc(sizeof(Interp));
  164.     iPtr->result = iPtr->resultSpace;
  165.     iPtr->freeProc = 0;
  166.     iPtr->errorLine = 0;
  167.     Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  168.     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
  169.     Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
  170.     iPtr->numLevels = 0;
  171.     iPtr->maxNestingDepth = 1000;
  172.     iPtr->framePtr = NULL;
  173.     iPtr->varFramePtr = NULL;
  174.     iPtr->activeTracePtr = NULL;
  175.     iPtr->returnCode = TCL_OK;
  176.     iPtr->errorInfo = NULL;
  177.     iPtr->errorCode = NULL;
  178.     iPtr->numEvents = 0;
  179.     iPtr->events = NULL;
  180.     iPtr->curEvent = 0;
  181.     iPtr->curEventNum = 0;
  182.     iPtr->revPtr = NULL;
  183.     iPtr->historyFirst = NULL;
  184.     iPtr->revDisables = 1;
  185.     iPtr->evalFirst = iPtr->evalLast = NULL;
  186.     iPtr->appendResult = NULL;
  187.     iPtr->appendAvl = 0;
  188.     iPtr->appendUsed = 0;
  189.     for (i = 0; i < NUM_REGEXPS; i++) {
  190.     iPtr->patterns[i] = NULL;
  191.     iPtr->patLengths[i] = -1;
  192.     iPtr->regexps[i] = NULL;
  193.     }
  194.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  195.     iPtr->pdPrec = DEFAULT_PD_PREC;
  196.     iPtr->cmdCount = 0;
  197.     iPtr->noEval = 0;
  198.     iPtr->evalFlags = 0;
  199.     iPtr->scriptFile = NULL;
  200.     iPtr->flags = 0;
  201.     iPtr->tracePtr = NULL;
  202.     iPtr->deleteCallbackPtr = NULL;
  203.     iPtr->resultSpace[0] = 0;
  204.  
  205.     /*
  206.      * Create the built-in commands.  Do it here, rather than calling
  207.      * Tcl_CreateCommand, because it's faster (there's no need to
  208.      * check for a pre-existing command by the same name).
  209.      */
  210.  
  211.     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
  212.     int new;
  213.     Tcl_HashEntry *hPtr;
  214.  
  215.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
  216.         cmdInfoPtr->name, &new);
  217.     if (new) {
  218.         cmdPtr = (Command *) ckalloc(sizeof(Command));
  219.         cmdPtr->proc = cmdInfoPtr->proc;
  220.         cmdPtr->clientData = (ClientData) NULL;
  221.         cmdPtr->deleteProc = NULL;
  222.         cmdPtr->deleteData = (ClientData) NULL;
  223.         Tcl_SetHashValue(hPtr, cmdPtr);
  224.     }
  225.     }
  226.  
  227. #ifndef TCL_GENERIC_ONLY
  228.     TclSetupEnv((Tcl_Interp *) iPtr);
  229.  
  230.     /*
  231.      * The code below causes SIGPIPE (broken pipe) errors to
  232.      * be ignored.  This is needed so that Tcl processes don't
  233.      * die if they create child processes (e.g. using "exec" or
  234.      * "open") that terminate prematurely.  The signal handler
  235.      * is only set up when the first interpreter is created; 
  236.      * after this the application can override the handler with
  237.      * a different one of its own, if it wants.
  238.      */
  239.  
  240.     if (firstInterp) {
  241. #ifndef macintosh
  242.     (void) signal(SIGPIPE, SIG_IGN);
  243. #endif
  244.     firstInterp = 0;
  245.     }
  246. #endif
  247.  
  248.     Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
  249.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  250.         TclPrecTraceProc, (ClientData) NULL);
  251.     return (Tcl_Interp *) iPtr;
  252. }
  253.  
  254. /*
  255.  *----------------------------------------------------------------------
  256.  *
  257.  * Tcl_Init --
  258.  *
  259.  *    This procedure is typically invoked by Tcl_AppInit procedures
  260.  *    to perform additional initialization for a Tcl interpreter,
  261.  *    such as sourcing the "init.tcl" script.
  262.  *
  263.  * Results:
  264.  *    Returns a standard Tcl completion code and sets interp->result
  265.  *    if there is an error.
  266.  *
  267.  * Side effects:
  268.  *    Depends on what's in the init.tcl script.
  269.  *
  270.  *----------------------------------------------------------------------
  271.  */
  272.  
  273. int
  274. Tcl_Init(interp)
  275.     Tcl_Interp *interp;        /* Interpreter to initialize. */
  276. {
  277. #ifdef macintosh
  278.     static char initCmd[] =
  279.     "if [file exists [info library]:init.tcl] {\n\
  280.         source [info library]:init.tcl\n\
  281.     } else {\n\
  282.         set msg \"can't find [info library]:init.tcl; perhaps you \"\n\
  283.         append msg \"need to\\ninstall the Tcl library folder or \"\n\
  284.         append msg \"set your TCL_LIBRARY environment variable?\"\n\
  285.         error $msg\n\
  286.     }";
  287. #else
  288.     static char initCmd[] =
  289.     "if [file exists [info library]/init.tcl] {\n\
  290.         source [info library]/init.tcl\n\
  291.     } else {\n\
  292.         set msg \"can't find [info library]/init.tcl; perhaps you \"\n\
  293.         append msg \"need to\\ninstall Tcl or set your TCL_LIBRARY \"\n\
  294.         append msg \"environment variable?\"\n\
  295.         error $msg\n\
  296.     }";
  297. #endif
  298.  
  299.     return Tcl_Eval(interp, initCmd);
  300. }
  301.  
  302. /*
  303.  *--------------------------------------------------------------
  304.  *
  305.  * Tcl_CallWhenDeleted --
  306.  *
  307.  *    Arrange for a procedure to be called before a given
  308.  *    interpreter is deleted.
  309.  *
  310.  * Results:
  311.  *    None.
  312.  *
  313.  * Side effects:
  314.  *    When Tcl_DeleteInterp is invoked to delete interp,
  315.  *    proc will be invoked.  See the manual entry for
  316.  *    details.
  317.  *
  318.  *--------------------------------------------------------------
  319.  */
  320.  
  321. void
  322. Tcl_CallWhenDeleted(interp, proc, clientData)
  323.     Tcl_Interp *interp;        /* Interpreter to watch. */
  324.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  325.                  * is about to be deleted. */
  326.     ClientData clientData;    /* One-word value to pass to proc. */
  327. {
  328.     DeleteCallback *dcPtr, *prevPtr;
  329.     Interp *iPtr = (Interp *) interp;
  330.  
  331.     dcPtr = (DeleteCallback *) ckalloc(sizeof(DeleteCallback));
  332.     dcPtr->proc = proc;
  333.     dcPtr->clientData = clientData;
  334.     dcPtr->nextPtr = NULL;
  335.     if (iPtr->deleteCallbackPtr == NULL) {
  336.     iPtr->deleteCallbackPtr = dcPtr;
  337.     } else {
  338.     prevPtr = iPtr->deleteCallbackPtr;
  339.     while (prevPtr->nextPtr != NULL) {
  340.         prevPtr = prevPtr->nextPtr;
  341.     }
  342.     prevPtr->nextPtr = dcPtr;
  343.     }
  344. }
  345.  
  346. /*
  347.  *--------------------------------------------------------------
  348.  *
  349.  * Tcl_DontCallWhenDeleted --
  350.  *
  351.  *    Cancel the arrangement for a procedure to be called when
  352.  *    a given interpreter is deleted.
  353.  *
  354.  * Results:
  355.  *    None.
  356.  *
  357.  * Side effects:
  358.  *    If proc and clientData were previously registered as a
  359.  *    callback via Tcl_CallWhenDeleted, they are unregistered.
  360.  *    If they weren't previously registered then nothing
  361.  *    happens.
  362.  *
  363.  *--------------------------------------------------------------
  364.  */
  365.  
  366. void
  367. Tcl_DontCallWhenDeleted(interp, proc, clientData)
  368.     Tcl_Interp *interp;        /* Interpreter to watch. */
  369.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  370.                  * is about to be deleted. */
  371.     ClientData clientData;    /* One-word value to pass to proc. */
  372. {
  373.     DeleteCallback *prevPtr, *dcPtr;
  374.     Interp *iPtr = (Interp *) interp;
  375.  
  376.     for (prevPtr = NULL, dcPtr = iPtr->deleteCallbackPtr;
  377.         dcPtr != NULL; prevPtr = dcPtr, dcPtr = dcPtr->nextPtr) {
  378.     if ((dcPtr->proc != proc) || (dcPtr->clientData != clientData)) {
  379.         continue;
  380.     }
  381.     if (prevPtr == NULL) {
  382.         iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  383.     } else {
  384.         prevPtr->nextPtr = dcPtr->nextPtr;
  385.     }
  386.     ckfree((char *) dcPtr);
  387.     break;
  388.     }
  389. }
  390.  
  391. /*
  392.  *----------------------------------------------------------------------
  393.  *
  394.  * Tcl_DeleteInterp --
  395.  *
  396.  *    Delete an interpreter and free up all of the resources associated
  397.  *    with it.
  398.  *
  399.  * Results:
  400.  *    None.
  401.  *
  402.  * Side effects:
  403.  *    The interpreter is destroyed.  The caller should never again
  404.  *    use the interp token.
  405.  *
  406.  *----------------------------------------------------------------------
  407.  */
  408.  
  409. void
  410. Tcl_DeleteInterp(interp)
  411.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  412.                  * by a previous call to Tcl_CreateInterp). */
  413. {
  414.     Interp *iPtr = (Interp *) interp;
  415.     Tcl_HashEntry *hPtr;
  416.     Tcl_HashSearch search;
  417.     register Command *cmdPtr;
  418.     DeleteCallback *dcPtr;
  419.     int i;
  420.  
  421.     /*
  422.      * If the interpreter is in use, delay the deletion until later.
  423.      */
  424.  
  425.     iPtr->flags |= DELETED;
  426.     if (iPtr->numLevels != 0) {
  427.     return;
  428.     }
  429.  
  430.     /*
  431.      * Invoke deletion callbacks.
  432.      */
  433.  
  434.     while (iPtr->deleteCallbackPtr != NULL) {
  435.     dcPtr = iPtr->deleteCallbackPtr;
  436.     iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  437.     (*dcPtr->proc)(dcPtr->clientData, interp);
  438.     ckfree((char *) dcPtr);
  439.     }
  440.  
  441.     /*
  442.      * Free up any remaining resources associated with the
  443.      * interpreter.
  444.      */
  445.  
  446.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  447.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  448.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  449.     if (cmdPtr->deleteProc != NULL) { 
  450.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  451.     }
  452.     ckfree((char *) cmdPtr);
  453.     }
  454.     Tcl_DeleteHashTable(&iPtr->commandTable);
  455.     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
  456.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  457.     ckfree((char *) Tcl_GetHashValue(hPtr));
  458.     }
  459.     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
  460.     TclDeleteVars(iPtr, &iPtr->globalTable);
  461.  
  462.     /*
  463.      * Free up the result *after* deleting variables, since variable
  464.      * deletion could have transferred ownership of the result string
  465.      * to Tcl.
  466.      */
  467.  
  468.     Tcl_FreeResult(interp);
  469.     if (iPtr->errorInfo != NULL) {
  470.     ckfree(iPtr->errorInfo);
  471.     }
  472.     if (iPtr->errorCode != NULL) {
  473.     ckfree(iPtr->errorCode);
  474.     }
  475.     if (iPtr->events != NULL) {
  476.     int i;
  477.  
  478.     for (i = 0; i < iPtr->numEvents; i++) {
  479.         ckfree(iPtr->events[i].command);
  480.     }
  481.     ckfree((char *) iPtr->events);
  482.     }
  483.     while (iPtr->revPtr != NULL) {
  484.     HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
  485.  
  486.     ckfree((char *) iPtr->revPtr);
  487.     iPtr->revPtr = nextPtr;
  488.     }
  489.     if (iPtr->appendResult != NULL) {
  490.     ckfree(iPtr->appendResult);
  491.     }
  492.     for (i = 0; i < NUM_REGEXPS; i++) {
  493.     if (iPtr->patterns[i] == NULL) {
  494.         break;
  495.     }
  496.     ckfree(iPtr->patterns[i]);
  497.     ckfree((char *) iPtr->regexps[i]);
  498.     }
  499.     while (iPtr->tracePtr != NULL) {
  500.     Trace *nextPtr = iPtr->tracePtr->nextPtr;
  501.  
  502.     ckfree((char *) iPtr->tracePtr);
  503.     iPtr->tracePtr = nextPtr;
  504.     }
  505.     ckfree((char *) iPtr);
  506. }
  507.  
  508. /*
  509.  *----------------------------------------------------------------------
  510.  *
  511.  * Tcl_CreateCommand --
  512.  *
  513.  *    Define a new command in a command table.
  514.  *
  515.  * Results:
  516.  *    None.
  517.  *
  518.  * Side effects:
  519.  *    If a command named cmdName already exists for interp, it is
  520.  *    deleted.  In the future, when cmdName is seen as the name of
  521.  *    a command by Tcl_Eval, proc will be called.  When the command
  522.  *    is deleted from the table, deleteProc will be called.  See the
  523.  *    manual entry for details on the calling sequence.
  524.  *
  525.  *----------------------------------------------------------------------
  526.  */
  527.  
  528. void
  529. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  530.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  531.                  * by a previous call to Tcl_CreateInterp). */
  532.     char *cmdName;        /* Name of command. */
  533.     Tcl_CmdProc *proc;        /* Command procedure to associate with
  534.                  * cmdName. */
  535.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  536.     Tcl_CmdDeleteProc *deleteProc;
  537.                 /* If not NULL, gives a procedure to call when
  538.                  * this command is deleted. */
  539. {
  540.     Interp *iPtr = (Interp *) interp;
  541.     register Command *cmdPtr;
  542.     Tcl_HashEntry *hPtr;
  543.     int new;
  544.  
  545.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  546.     if (!new) {
  547.     /*
  548.      * Command already exists:  delete the old one.
  549.      */
  550.  
  551.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  552.     if (cmdPtr->deleteProc != NULL) {
  553.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  554.     }
  555.     } else {
  556.     cmdPtr = (Command *) ckalloc(sizeof(Command));
  557.     Tcl_SetHashValue(hPtr, cmdPtr);
  558.     }
  559.     cmdPtr->proc = proc;
  560.     cmdPtr->clientData = clientData;
  561.     cmdPtr->deleteProc = deleteProc;
  562.     cmdPtr->deleteData = clientData;
  563. }
  564.  
  565. /*
  566.  *----------------------------------------------------------------------
  567.  *
  568.  * Tcl_SetCommandInfo --
  569.  *
  570.  *    Modifies various information about a Tcl command.
  571.  *
  572.  * Results:
  573.  *    If cmdName exists in interp, then the information at *infoPtr
  574.  *    is stored with the command in place of the current information
  575.  *    and 1 is returned.  If the command doesn't exist then 0 is
  576.  *    returned.
  577.  *
  578.  * Side effects:
  579.  *    None.
  580.  *
  581.  *----------------------------------------------------------------------
  582.  */
  583.  
  584. int
  585. Tcl_SetCommandInfo(interp, cmdName, infoPtr)
  586.     Tcl_Interp *interp;            /* Interpreter in which to look
  587.                      * for command. */
  588.     char *cmdName;            /* Name of desired command. */
  589.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  590.                      * command. */
  591. {
  592.     Tcl_HashEntry *hPtr;
  593.     Command *cmdPtr;
  594.  
  595.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  596.     if (hPtr == NULL) {
  597.     return 0;
  598.     }
  599.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  600.     cmdPtr->proc = infoPtr->proc;
  601.     cmdPtr->clientData = infoPtr->clientData;
  602.     cmdPtr->deleteProc = infoPtr->deleteProc;
  603.     cmdPtr->deleteData = infoPtr->deleteData;
  604.     return 1;
  605. }
  606.  
  607. /*
  608.  *----------------------------------------------------------------------
  609.  *
  610.  * Tcl_GetCommandInfo --
  611.  *
  612.  *    Returns various information about a Tcl command.
  613.  *
  614.  * Results:
  615.  *    If cmdName exists in interp, then *infoPtr is modified to
  616.  *    hold information about cmdName and 1 is returned.  If the
  617.  *    command doesn't exist then 0 is returned and *infoPtr isn't
  618.  *    modified.
  619.  *
  620.  * Side effects:
  621.  *    None.
  622.  *
  623.  *----------------------------------------------------------------------
  624.  */
  625.  
  626. int
  627. Tcl_GetCommandInfo(interp, cmdName, infoPtr)
  628.     Tcl_Interp *interp;            /* Interpreter in which to look
  629.                      * for command. */
  630.     char *cmdName;            /* Name of desired command. */
  631.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  632.                      * command. */
  633. {
  634.     Tcl_HashEntry *hPtr;
  635.     Command *cmdPtr;
  636.  
  637.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  638.     if (hPtr == NULL) {
  639.     return 0;
  640.     }
  641.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  642.     infoPtr->proc = cmdPtr->proc;
  643.     infoPtr->clientData = cmdPtr->clientData;
  644.     infoPtr->deleteProc = cmdPtr->deleteProc;
  645.     infoPtr->deleteData = cmdPtr->deleteData;
  646.     return 1;
  647. }
  648.  
  649. /*
  650.  *----------------------------------------------------------------------
  651.  *
  652.  * Tcl_DeleteCommand --
  653.  *
  654.  *    Remove the given command from the given interpreter.
  655.  *
  656.  * Results:
  657.  *    0 is returned if the command was deleted successfully.
  658.  *    -1 is returned if there didn't exist a command by that
  659.  *    name.
  660.  *
  661.  * Side effects:
  662.  *    CmdName will no longer be recognized as a valid command for
  663.  *    interp.
  664.  *
  665.  *----------------------------------------------------------------------
  666.  */
  667.  
  668. int
  669. Tcl_DeleteCommand(interp, cmdName)
  670.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  671.                  * by a previous call to Tcl_CreateInterp). */
  672.     char *cmdName;        /* Name of command to remove. */
  673. {
  674.     Interp *iPtr = (Interp *) interp;
  675.     Tcl_HashEntry *hPtr;
  676.     Command *cmdPtr;
  677.  
  678.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  679.     if (hPtr == NULL) {
  680.     return -1;
  681.     }
  682.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  683.     if (cmdPtr->deleteProc != NULL) {
  684.     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  685.     }
  686.     ckfree((char *) cmdPtr);
  687.     Tcl_DeleteHashEntry(hPtr);
  688.     return 0;
  689. }
  690.  
  691. /*
  692.  *-----------------------------------------------------------------
  693.  *
  694.  * Tcl_Eval --
  695.  *
  696.  *    Parse and execute a command in the Tcl language.
  697.  *
  698.  * Results:
  699.  *    The return value is one of the return codes defined in tcl.hd
  700.  *    (such as TCL_OK), and interp->result contains a string value
  701.  *    to supplement the return code.  The value of interp->result
  702.  *    will persist only until the next call to Tcl_Eval:  copy it or
  703.  *    lose it! *TermPtr is filled in with the character just after
  704.  *    the last one that was part of the command (usually a NULL
  705.  *    character or a closing bracket).
  706.  *
  707.  * Side effects:
  708.  *    Almost certainly;  depends on the command.
  709.  *
  710.  *-----------------------------------------------------------------
  711.  */
  712.  
  713. int
  714. Tcl_Eval(interp, cmd)
  715.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  716.                  * by a previous call to Tcl_CreateInterp). */
  717.     char *cmd;            /* Pointer to TCL command to interpret. */
  718. {
  719.     /*
  720.      * The storage immediately below is used to generate a copy
  721.      * of the command, after all argument substitutions.  Pv will
  722.      * contain the argv values passed to the command procedure.
  723.      */
  724.  
  725. #   define NUM_CHARS 200
  726.     char copyStorage[NUM_CHARS];
  727.     ParseValue pv;
  728.     char *oldBuffer;
  729.  
  730.     /*
  731.      * This procedure generates an (argv, argc) array for the command,
  732.      * It starts out with stack-allocated space but uses dynamically-
  733.      * allocated storage to increase it if needed.
  734.      */
  735.  
  736. #   define NUM_ARGS 10
  737.     char *(argStorage[NUM_ARGS]);
  738.     char **argv = argStorage;
  739.     int argc;
  740.     int argSize = NUM_ARGS;
  741.  
  742.     register char *src;            /* Points to current character
  743.                      * in cmd. */
  744.     char termChar;            /* Return when this character is found
  745.                      * (either ']' or '\0').  Zero means
  746.                      * that newlines terminate commands. */
  747.     int flags;                /* Interp->evalFlags value when the
  748.                      * procedure was called. */
  749.     int result;                /* Return value. */
  750.     register Interp *iPtr = (Interp *) interp;
  751.     Tcl_HashEntry *hPtr;
  752.     Command *cmdPtr;
  753.     char *termPtr;            /* Contains character just after the
  754.                      * last one in the command. */
  755.     char *cmdStart;            /* Points to first non-blank char. in
  756.                      * command (used in calling trace
  757.                      * procedures). */
  758.     char *ellipsis = "";        /* Used in setting errorInfo variable;
  759.                      * set to "..." to indicate that not
  760.                      * all of offending command is included
  761.                      * in errorInfo.  "" means that the
  762.                      * command is all there. */
  763.     register Trace *tracePtr;
  764.  
  765.     /*
  766.      * Initialize the result to an empty string and clear out any
  767.      * error information.  This makes sure that we return an empty
  768.      * result if there are no commands in the command string.
  769.      */
  770.  
  771.     Tcl_FreeResult((Tcl_Interp *) iPtr);
  772.     iPtr->result = iPtr->resultSpace;
  773.     iPtr->resultSpace[0] = 0;
  774.     result = TCL_OK;
  775.  
  776.     /*
  777.      * Initialize the area in which command copies will be assembled.
  778.      */
  779.  
  780.     pv.buffer = copyStorage;
  781.     pv.end = copyStorage + NUM_CHARS - 1;
  782.     pv.expandProc = TclExpandParseValue;
  783.     pv.clientData = (ClientData) NULL;
  784.  
  785.     src = cmd;
  786.     flags = iPtr->evalFlags;
  787.     iPtr->evalFlags = 0;
  788.     if (flags & TCL_BRACKET_TERM) {
  789.     termChar = ']';
  790.     } else {
  791.     termChar = 0;
  792.     }
  793.     termPtr = src;
  794.     cmdStart = src;
  795.  
  796.     /*
  797.      * Check depth of nested calls to Tcl_Eval:  if this gets too large,
  798.      * it's probably because of an infinite loop somewhere.
  799.      */
  800.  
  801.     iPtr->numLevels++;
  802.     if (iPtr->numLevels > iPtr->maxNestingDepth) {
  803.     iPtr->numLevels--;
  804.     iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
  805.     iPtr->termPtr = termPtr;
  806.     return TCL_ERROR;
  807.     }
  808.  
  809.     /*
  810.      * There can be many sub-commands (separated by semi-colons or
  811.      * newlines) in one command string.  This outer loop iterates over
  812.      * individual commands.
  813.      */
  814.  
  815.     while (*src != termChar) {
  816.     iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
  817.  
  818. #ifdef macintosh
  819.         if ( TclMac_User_Wants_Break(interp) )
  820.             {
  821.             result = TCL_ERROR;
  822.             break;
  823.             }
  824. #endif
  825.  
  826.     /*
  827.      * Skim off leading white space and semi-colons, and skip
  828.      * comments.
  829.      */
  830.  
  831.     while (1) {
  832.         register char c = *src;
  833. #ifdef THINK_C
  834.         if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n') && (c != '\r')) {
  835. #else
  836.         if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
  837. #endif
  838.         break;
  839.         }
  840.         src += 1;
  841.     }
  842.     if (*src == '#') {
  843.         for (src++; *src != 0; src++) {
  844. #ifdef THINK_C
  845.         if ( ((*src == '\n')||(*src == '\r')) && (src[-1] != '\\') ) {
  846. #else
  847.         if ((*src == '\n') && (src[-1] != '\\')) {
  848. #endif
  849.             src++;
  850.             break;
  851.         }
  852.         }
  853.         continue;
  854.     }
  855.     cmdStart = src;
  856.  
  857.     /*
  858.      * Parse the words of the command, generating the argc and
  859.      * argv for the command procedure.  May have to call
  860.      * TclParseWords several times, expanding the argv array
  861.      * between calls.
  862.      */
  863.  
  864.     pv.next = oldBuffer = pv.buffer;
  865.     argc = 0;
  866.     while (1) {
  867.         int newArgs, maxArgs;
  868.         char **newArgv;
  869.         int i;
  870.  
  871.         /*
  872.          * Note:  the "- 2" below guarantees that we won't use the
  873.          * last two argv slots here.  One is for a NULL pointer to
  874.          * mark the end of the list, and the other is to leave room
  875.          * for inserting the command name "unknown" as the first
  876.          * argument (see below).
  877.          */
  878.  
  879.         maxArgs = argSize - argc - 2;
  880.         result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
  881.             maxArgs, &termPtr, &newArgs, &argv[argc], &pv);
  882.         src = termPtr;
  883.         if (result != TCL_OK) {
  884.         ellipsis = "...";
  885.         goto done;
  886.         }
  887.  
  888.         /*
  889.          * Careful!  Buffer space may have gotten reallocated while
  890.          * parsing words.  If this happened, be sure to update all
  891.          * of the older argv pointers to refer to the new space.
  892.          */
  893.  
  894.         if (oldBuffer != pv.buffer) {
  895.         int i;
  896.  
  897.         for (i = 0; i < argc; i++) {
  898.             argv[i] = pv.buffer + (argv[i] - oldBuffer);
  899.         }
  900.         oldBuffer = pv.buffer;
  901.         }
  902.         argc += newArgs;
  903.         if (newArgs < maxArgs) {
  904.         argv[argc] = (char *) NULL;
  905.         break;
  906.         }
  907.  
  908.         /*
  909.          * Args didn't all fit in the current array.  Make it bigger.
  910.          */
  911.  
  912.         argSize *= 2;
  913.         newArgv = (char **)
  914.             ckalloc((unsigned) argSize * sizeof(char *));
  915.         for (i = 0; i < argc; i++) {
  916.         newArgv[i] = argv[i];
  917.         }
  918.         if (argv != argStorage) {
  919.         ckfree((char *) argv);
  920.         }
  921.         argv = newArgv;
  922.     }
  923.  
  924.     /*
  925.      * If this is an empty command (or if we're just parsing
  926.      * commands without evaluating them), then just skip to the
  927.      * next command.
  928.      */
  929.  
  930.     if ((argc == 0) || iPtr->noEval) {
  931.         continue;
  932.     }
  933.     argv[argc] = NULL;
  934.  
  935.     /*
  936.      * Save information for the history module, if needed.
  937.      */
  938.  
  939.     if (flags & TCL_RECORD_BOUNDS) {
  940.         iPtr->evalFirst = cmdStart;
  941.         iPtr->evalLast = src-1;
  942.     }
  943.  
  944.     /*
  945.      * Find the procedure to execute this command.  If there isn't
  946.      * one, then see if there is a command "unknown".  If so,
  947.      * invoke it instead, passing it the words of the original
  948.      * command as arguments.
  949.      */
  950.  
  951.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
  952.     if (hPtr == NULL) {
  953.         int i;
  954.  
  955.         hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
  956.         if (hPtr == NULL) {
  957.         Tcl_ResetResult(interp);
  958.         Tcl_AppendResult(interp, "invalid command name: \"",
  959.             argv[0], "\"", (char *) NULL);
  960.         result = TCL_ERROR;
  961.         goto done;
  962.         }
  963.         for (i = argc; i >= 0; i--) {
  964.         argv[i+1] = argv[i];
  965.         }
  966.         argv[0] = "unknown";
  967.         argc++;
  968.     }
  969.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  970.  
  971.     /*
  972.      * Call trace procedures, if any.
  973.      */
  974.  
  975.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  976.         tracePtr = tracePtr->nextPtr) {
  977.         char saved;
  978.  
  979.         if (tracePtr->level < iPtr->numLevels) {
  980.         continue;
  981.         }
  982.         saved = *src;
  983.         *src = 0;
  984.         (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
  985.             cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
  986.         *src = saved;
  987.     }
  988.  
  989.     /*
  990.      * At long last, invoke the command procedure.  Reset the
  991.      * result to its default empty value first (it could have
  992.      * gotten changed by earlier commands in the same command
  993.      * string).
  994.      */
  995.  
  996.     iPtr->cmdCount++;
  997.     Tcl_FreeResult(iPtr);
  998.     iPtr->result = iPtr->resultSpace;
  999.     iPtr->resultSpace[0] = 0;
  1000.     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
  1001.     
  1002.     if (tcl_AsyncReady) {
  1003.         result = Tcl_AsyncInvoke(interp, result);
  1004.     }
  1005.     if (result != TCL_OK) {
  1006.         break;
  1007.     }
  1008.     }
  1009.  
  1010.     /*
  1011.      * Free up any extra resources that were allocated.
  1012.      */
  1013.  
  1014.     done:
  1015.     if (pv.buffer != copyStorage) {
  1016.     ckfree((char *) pv.buffer);
  1017.     }
  1018.     if (argv != argStorage) {
  1019.     ckfree((char *) argv);
  1020.     }
  1021.     iPtr->numLevels--;
  1022.     if (iPtr->numLevels == 0) {
  1023.     if (result == TCL_RETURN) {
  1024.         result = TCL_OK;
  1025.     }
  1026.     if ((result != TCL_OK) && (result != TCL_ERROR)) {
  1027.         Tcl_ResetResult(interp);
  1028.         if (result == TCL_BREAK) {
  1029.         iPtr->result = "invoked \"break\" outside of a loop";
  1030.         } else if (result == TCL_CONTINUE) {
  1031.         iPtr->result = "invoked \"continue\" outside of a loop";
  1032.         } else {
  1033.         iPtr->result = iPtr->resultSpace;
  1034.         sprintf(iPtr->resultSpace, "command returned bad code: %d",
  1035.             result);
  1036.         }
  1037.         result = TCL_ERROR;
  1038.     }
  1039.     if (iPtr->flags & DELETED) {
  1040.         Tcl_DeleteInterp(interp);
  1041.     }
  1042.     }
  1043.  
  1044.     /*
  1045.      * If an error occurred, record information about what was being
  1046.      * executed when the error occurred.
  1047.      */
  1048.  
  1049.     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
  1050.     int numChars;
  1051.     register char *p;
  1052.  
  1053.     /*
  1054.      * Compute the line number where the error occurred.
  1055.      */
  1056.  
  1057.     iPtr->errorLine = 1;
  1058.     for (p = cmd; p != cmdStart; p++) {
  1059. #ifdef THINK_C
  1060.         if (*p == '\n'||*p == '\r') {
  1061. #else
  1062.         if (*p == '\n') {
  1063. #endif
  1064.         iPtr->errorLine++;
  1065.         }
  1066.     }
  1067.     for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
  1068. #ifdef THINK_C
  1069.         if (*p == '\n'||*p == '\r') {
  1070. #else
  1071.         if (*p == '\n') {
  1072. #endif
  1073.         iPtr->errorLine++;
  1074.         }
  1075.     }
  1076.  
  1077.     /*
  1078.      * Figure out how much of the command to print in the error
  1079.      * message (up to a certain number of characters, or up to
  1080.      * the first new-line).
  1081.      */
  1082.  
  1083.     numChars = src - cmdStart;
  1084.     if (numChars > (NUM_CHARS-50)) {
  1085.         numChars = NUM_CHARS-50;
  1086.         ellipsis = " ...";
  1087.     }
  1088.  
  1089.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1090.         sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
  1091.             numChars, cmdStart, ellipsis);
  1092.     } else {
  1093.         sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
  1094.             numChars, cmdStart, ellipsis);
  1095.     }
  1096.     Tcl_AddErrorInfo(interp, copyStorage);
  1097.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1098.     } else {
  1099.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1100.     }
  1101.     iPtr->termPtr = termPtr;
  1102.     return result;
  1103. }
  1104.  
  1105. /*
  1106.  *----------------------------------------------------------------------
  1107.  *
  1108.  * Tcl_CreateTrace --
  1109.  *
  1110.  *    Arrange for a procedure to be called to trace command execution.
  1111.  *
  1112.  * Results:
  1113.  *    The return value is a token for the trace, which may be passed
  1114.  *    to Tcl_DeleteTrace to eliminate the trace.
  1115.  *
  1116.  * Side effects:
  1117.  *    From now on, proc will be called just before a command procedure
  1118.  *    is called to execute a Tcl command.  Calls to proc will have the
  1119.  *    following form:
  1120.  *
  1121.  *    void
  1122.  *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
  1123.  *        argc, argv)
  1124.  *        ClientData clientData;
  1125.  *        Tcl_Interp *interp;
  1126.  *        int level;
  1127.  *        char *command;
  1128.  *        int (*cmdProc)();
  1129.  *        ClientData cmdClientData;
  1130.  *        int argc;
  1131.  *        char **argv;
  1132.  *    {
  1133.  *    }
  1134.  *
  1135.  *    The clientData and interp arguments to proc will be the same
  1136.  *    as the corresponding arguments to this procedure.  Level gives
  1137.  *    the nesting level of command interpretation for this interpreter
  1138.  *    (0 corresponds to top level).  Command gives the ASCII text of
  1139.  *    the raw command, cmdProc and cmdClientData give the procedure that
  1140.  *    will be called to process the command and the ClientData value it
  1141.  *    will receive, and argc and argv give the arguments to the
  1142.  *    command, after any argument parsing and substitution.  Proc
  1143.  *    does not return a value.
  1144.  *
  1145.  *----------------------------------------------------------------------
  1146.  */
  1147.  
  1148. Tcl_Trace
  1149. Tcl_CreateTrace(interp, level, proc, clientData)
  1150.     Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
  1151.     int level;            /* Only call proc for commands at nesting level
  1152.                  * <= level (1 => top level). */
  1153.     Tcl_CmdTraceProc *proc;    /* Procedure to call before executing each
  1154.                  * command. */
  1155.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  1156. {
  1157.     register Trace *tracePtr;
  1158.     register Interp *iPtr = (Interp *) interp;
  1159.  
  1160.     tracePtr = (Trace *) ckalloc(sizeof(Trace));
  1161.     tracePtr->level = level;
  1162.     tracePtr->proc = proc;
  1163.     tracePtr->clientData = clientData;
  1164.     tracePtr->nextPtr = iPtr->tracePtr;
  1165.     iPtr->tracePtr = tracePtr;
  1166.  
  1167.     return (Tcl_Trace) tracePtr;
  1168. }
  1169.  
  1170. /*
  1171.  *----------------------------------------------------------------------
  1172.  *
  1173.  * Tcl_DeleteTrace --
  1174.  *
  1175.  *    Remove a trace.
  1176.  *
  1177.  * Results:
  1178.  *    None.
  1179.  *
  1180.  * Side effects:
  1181.  *    From now on there will be no more calls to the procedure given
  1182.  *    in trace.
  1183.  *
  1184.  *----------------------------------------------------------------------
  1185.  */
  1186.  
  1187. void
  1188. Tcl_DeleteTrace(interp, trace)
  1189.     Tcl_Interp *interp;        /* Interpreter that contains trace. */
  1190.     Tcl_Trace trace;        /* Token for trace (returned previously by
  1191.                  * Tcl_CreateTrace). */
  1192. {
  1193.     register Interp *iPtr = (Interp *) interp;
  1194.     register Trace *tracePtr = (Trace *) trace;
  1195.     register Trace *tracePtr2;
  1196.  
  1197.     if (iPtr->tracePtr == tracePtr) {
  1198.     iPtr->tracePtr = tracePtr->nextPtr;
  1199.     ckfree((char *) tracePtr);
  1200.     } else {
  1201.     for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
  1202.         tracePtr2 = tracePtr2->nextPtr) {
  1203.         if (tracePtr2->nextPtr == tracePtr) {
  1204.         tracePtr2->nextPtr = tracePtr->nextPtr;
  1205.         ckfree((char *) tracePtr);
  1206.         return;
  1207.         }
  1208.     }
  1209.     }
  1210. }
  1211.  
  1212. /*
  1213.  *----------------------------------------------------------------------
  1214.  *
  1215.  * Tcl_AddErrorInfo --
  1216.  *
  1217.  *    Add information to a message being accumulated that describes
  1218.  *    the current error.
  1219.  *
  1220.  * Results:
  1221.  *    None.
  1222.  *
  1223.  * Side effects:
  1224.  *    The contents of message are added to the "errorInfo" variable.
  1225.  *    If Tcl_Eval has been called since the current value of errorInfo
  1226.  *    was set, errorInfo is cleared before adding the new message.
  1227.  *
  1228.  *----------------------------------------------------------------------
  1229.  */
  1230.  
  1231. void
  1232. Tcl_AddErrorInfo(interp, message)
  1233.     Tcl_Interp *interp;        /* Interpreter to which error information
  1234.                  * pertains. */
  1235.     char *message;        /* Message to record. */
  1236. {
  1237.     register Interp *iPtr = (Interp *) interp;
  1238.  
  1239.     /*
  1240.      * If an error is already being logged, then the new errorInfo
  1241.      * is the concatenation of the old info and the new message.
  1242.      * If this is the first piece of info for the error, then the
  1243.      * new errorInfo is the concatenation of the message in
  1244.      * interp->result and the new message.
  1245.      */
  1246.  
  1247. /*
  1248. ** Here's a shit hack. Think's line termination reality
  1249. ** is very warped. Thus, we convert where necessary...
  1250. */
  1251. #if defined(THINK_C) && defined(TCLAPPL)
  1252.     char *buffer = NULL, *fptr, *tptr;
  1253.     
  1254.     buffer = ckalloc( strlen(message) + 1 );
  1255.     if (buffer != NULL)
  1256.         {
  1257.         for ( fptr = message, tptr = buffer ; *fptr ; )
  1258.             if ( (*tptr++ = *fptr++) == '\n')
  1259.                 *(tptr - 1) = '\r';
  1260.         *tptr = '\0';
  1261.         message = buffer;
  1262.         }
  1263. #endif
  1264.  
  1265.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1266.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
  1267.         TCL_GLOBAL_ONLY);
  1268.     iPtr->flags |= ERR_IN_PROGRESS;
  1269.  
  1270.     /*
  1271.      * If the errorCode variable wasn't set by the code that generated
  1272.      * the error, set it to "NONE".
  1273.      */
  1274.  
  1275.     if (!(iPtr->flags & ERROR_CODE_SET)) {
  1276.         (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
  1277.             TCL_GLOBAL_ONLY);
  1278.     }
  1279.     }
  1280.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
  1281.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
  1282.  
  1283. #if defined(THINK_C) && defined(TCLAPPL)
  1284.     if (buffer != NULL)
  1285.         ckfree(buffer);
  1286. #endif
  1287. }
  1288.  
  1289. /*
  1290.  *----------------------------------------------------------------------
  1291.  *
  1292.  * Tcl_VarEval --
  1293.  *
  1294.  *    Given a variable number of string arguments, concatenate them
  1295.  *    all together and execute the result as a Tcl command.
  1296.  *
  1297.  * Results:
  1298.  *    A standard Tcl return result.  An error message or other
  1299.  *    result may be left in interp->result.
  1300.  *
  1301.  * Side effects:
  1302.  *    Depends on what was done by the command.
  1303.  *
  1304.  *----------------------------------------------------------------------
  1305.  */
  1306.     /* VARARGS2 */ /* ARGSUSED */
  1307. #ifdef macintosh
  1308.  
  1309. int
  1310. Tcl_VarEval(Tcl_Interp    *interp_p, ...)
  1311. {
  1312.  
  1313. #else
  1314.  
  1315. int
  1316. #ifndef lint
  1317. Tcl_VarEval(va_alist)
  1318. #else
  1319. Tcl_VarEval(interp_p, p, va_alist)
  1320.     Tcl_Interp *interp_p;        /* Interpreter in which to execute command. */
  1321.     char *p;            /* One or more strings to concatenate,
  1322.                  * terminated with a NULL string. */
  1323. #endif
  1324.     va_dcl;
  1325. {
  1326.     Tcl_Interp *interp;
  1327.  
  1328. #endif
  1329.  
  1330.     va_list argList;
  1331. #define FIXED_SIZE 200
  1332.     char fixedSpace[FIXED_SIZE+1];
  1333.     int spaceAvl, spaceUsed, length;
  1334.     char *string, *cmd;
  1335.     Tcl_Interp *interp;
  1336.     int result;
  1337.  
  1338.     /*
  1339.      * Copy the strings one after the other into a single larger
  1340.      * string.  Use stack-allocated space for small commands, but if
  1341.      * the command gets too large than call ckalloc to create the
  1342.      * space.
  1343.      */
  1344.  
  1345. #ifdef macintosh
  1346.     interp = interp_p;
  1347.     va_start(argList, interp_p);
  1348. #else
  1349.     va_start(argList);
  1350. #endif
  1351.  
  1352. #ifndef macintosh
  1353.     interp = va_arg(argList, Tcl_Interp *);
  1354. #endif
  1355.  
  1356.     spaceAvl = FIXED_SIZE;
  1357.     spaceUsed = 0;
  1358.     cmd = fixedSpace;
  1359.     while (1) {
  1360.     string = va_arg(argList, char *);
  1361.     if (string == NULL)
  1362.         {
  1363.         break;
  1364.         }
  1365.     length = strlen(string);
  1366.     if ((spaceUsed + length) > spaceAvl) {
  1367.         char *new;
  1368.  
  1369.         spaceAvl = spaceUsed + length;
  1370.         spaceAvl += spaceAvl/2;
  1371.         new = ckalloc((unsigned) spaceAvl);
  1372.         memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
  1373.         if (cmd != fixedSpace) {
  1374.         ckfree(cmd);
  1375.         }
  1376.         cmd = new;
  1377.     }
  1378.     strcpy(cmd + spaceUsed, string);
  1379.     spaceUsed += length;
  1380.     }
  1381.     va_end(argList);
  1382.     cmd[spaceUsed] = '\0';
  1383.  
  1384.     result = Tcl_Eval(interp, cmd);
  1385.     if (cmd != fixedSpace) {
  1386.     ckfree(cmd);
  1387.     }
  1388.     return result;
  1389. }
  1390.  
  1391. /*
  1392.  *----------------------------------------------------------------------
  1393.  *
  1394.  * Tcl_GlobalEval --
  1395.  *
  1396.  *    Evaluate a command at global level in an interpreter.
  1397.  *
  1398.  * Results:
  1399.  *    A standard Tcl result is returned, and interp->result is
  1400.  *    modified accordingly.
  1401.  *
  1402.  * Side effects:
  1403.  *    The command string is executed in interp, and the execution
  1404.  *    is carried out in the variable context of global level (no
  1405.  *    procedures active), just as if an "uplevel #0" command were
  1406.  *    being executed.
  1407.  *
  1408.  *----------------------------------------------------------------------
  1409.  */
  1410.  
  1411. int
  1412. Tcl_GlobalEval(interp, command)
  1413.     Tcl_Interp *interp;        /* Interpreter in which to evaluate command. */
  1414.     char *command;        /* Command to evaluate. */
  1415. {
  1416.     register Interp *iPtr = (Interp *) interp;
  1417.     int result;
  1418.     CallFrame *savedVarFramePtr;
  1419.  
  1420.     savedVarFramePtr = iPtr->varFramePtr;
  1421.     iPtr->varFramePtr = NULL;
  1422.     result = Tcl_Eval(interp, command);
  1423.     iPtr->varFramePtr = savedVarFramePtr;
  1424.     return result;
  1425. }
  1426.  
  1427. /*
  1428.  *----------------------------------------------------------------------
  1429.  *
  1430.  * Tcl_SetRecursionLimit --
  1431.  *
  1432.  *    Set the maximum number of recursive calls that may be active
  1433.  *    for an interpreter at once.
  1434.  *
  1435.  * Results:
  1436.  *    The return value is the old limit on nesting for interp.
  1437.  *
  1438.  * Side effects:
  1439.  *    None.
  1440.  *
  1441.  *----------------------------------------------------------------------
  1442.  */
  1443.  
  1444. int
  1445. Tcl_SetRecursionLimit(interp, depth)
  1446.     Tcl_Interp *interp;            /* Interpreter whose nesting limit
  1447.                      * is to be set. */
  1448.     int depth;                /* New value for maximimum depth. */
  1449. {
  1450.     Interp *iPtr = (Interp *) interp;
  1451.     int old;
  1452.  
  1453.     old = iPtr->maxNestingDepth;
  1454.     if (depth > 0) {
  1455.     iPtr->maxNestingDepth = depth;
  1456.     }
  1457.     return old;
  1458. }
  1459.